home *** CD-ROM | disk | FTP | other *** search
/ Libris Britannia 4 / science library(b).zip / science library(b) / PROGRAMM / PASCAL / 0189.ZIP / DATTOPIC.PAS < prev    next >
Pascal/Delphi Source File  |  1986-02-09  |  9KB  |  255 lines
  1. (***************************************************************)
  2. (*                                                             *)
  3. (*        FILER A LA PASCAL DATA BASE SOURCE CODE FILE         *)
  4. (*                                                             *)
  5. (*        (C) 1985 by  John M. Harlan                          *)
  6. (*                     24000 Telegraph                         *)
  7. (*                     Southfield, MI. 48034                   *)
  8. (*                                                             *)
  9. (*     The FILER GROUP of programs is released on a "FREE      *)
  10. (*     SOFTWARE" basis.  The recipient is free to examine      *)
  11. (*     and use the software with the understanding that if     *)
  12. (*     the FILER GROUP of programs prove to be of use and      *)
  13. (*     value,  a contribution to the author is encouraged.     *)
  14. (*                                                             *)
  15. (*     While reasonable effort has been made to ensure the     *)
  16. (*     reliability of the FILER GROUP of programs, no war-     *)
  17. (*     ranty is given. The recipient uses the programs at      *)
  18. (*     his own risk  and in no event shall the author be       *)
  19. (*     liable for damages arising from their use.              *)
  20. (*                                                             *)
  21. (*                                                             *)
  22. (***************************************************************)
  23.  
  24.  
  25. program dattopic;  { ONE OF THE FILER GROUP OF PROGRAMS }
  26. { CONVERTS A FILER DAT FILE TO A PIC FILE }
  27. { DATTOPIC.PAS  VERSION 2.0 }
  28. { MAY 20, 1985 }
  29.  
  30. { Formatted 2/7/86 by Doug Stevens using Pformat and the Turbo
  31.   editors global search/replace. Original version was 100%
  32.   upper case and very hard to read. }
  33.  
  34. label QUIT;
  35.  
  36. type
  37.   Range          = array[1..256] of char;
  38.   String79       = string[79];
  39.   NameStr        = string[12];
  40. var
  41.  
  42.   ch,option      : char;
  43.  
  44.   filenme        : string[6];
  45.   filedate       : string[8];
  46.   filename       : string[12];
  47.   ans            : String79;
  48.   mess           : String79;
  49.  
  50.   v,w,x,z,
  51.   maxnbrrec, nbrrecused, rcdlen,
  52.   blockingfactor, fieldperrecord,
  53.   ascii, decptr                              :    integer;
  54.  
  55.   fileexists                                 :    boolean;
  56.  
  57.  
  58.   labellength, datalen, dataform,
  59.   labelposn, dataposn, row,
  60.   column, fieldnbr                  :    array[1..32] of integer;
  61.   lbl                               :    array[1..384] of char;
  62.   line                              :    array[1..30] of String79;
  63.   getdata                           :    Range;
  64.  
  65.   source                            :    file;
  66.   dattopic                          :    text;
  67.  
  68. {================================================================}
  69. {        BINARY CODED DECIMAL TO INTEGER FUNCTION                }
  70. {================================================================}
  71. function BcdToInt (cha : char) : integer;
  72. begin
  73.   BcdToInt := ord(cha) - trunc(ord(cha)/16)*6;
  74. end;
  75. {================================================================}
  76. {             CHARACTER TO INTEGER FUNCTION                      }
  77. {================================================================}
  78. function ChrToInt(var charray : Range; start, len : integer)  : integer;
  79. var
  80.   code, result : integer;
  81.   workstring   : string[10];
  82. begin
  83.   workstring := '';
  84.   for result := 0 to len-1  do
  85.     begin
  86.       if charray[start + result ] = ' ' then
  87.         workstring := workstring + '0'
  88.       else workstring := workstring + charray[start+result];
  89.     end;
  90.   val(workstring,result,code);
  91.   ChrToInt := result;
  92. end;
  93. {===============================================================}
  94. {                       FUNCTION EXIST                          }
  95. {===============================================================}
  96. function Exist(filename : NameStr) : boolean;
  97. var
  98.   fil    :  file;
  99.   status : integer;
  100.  
  101. begin
  102.   Assign(fil,filename);
  103.   {$I-}
  104.   reset(fil);
  105.   {$I+}
  106.   Exist := (IOResult = 0);
  107. {$I-} Close(fil); status := IOResult; {$I+}
  108. end;
  109.  
  110. {################################################################}
  111. {                                                                }
  112. {                         MAIN PROGRAM                           }
  113. {                         ============                           }
  114. {################################################################}
  115.  
  116.  
  117. begin
  118.   repeat
  119.     ClrScr;
  120.     GotoXY(1,24);
  121.     writeln('"DATTOPIC" CONVERTS FILES FROM XXX.DAT TO XXX.PIC');
  122.     writeln;
  123.     write('ENTER FILENAME OF PICTURE FILE : ');
  124.     readln(filename);
  125.     x := pos('.',filename);
  126.     if x <> 0 then filename := copy(filename,1,x-1);
  127.     if filename = 'END' then goto QUIT;   { Quick and dirty exit. }
  128.     filename := filename + '.DAT';
  129.     writeln(filename);
  130.     fileexists := Exist(filename);
  131.   until fileexists = true;
  132.   Assign( source, filename );
  133.   reset( source );
  134.   Seek(source,1);
  135.   blockread( source,getdata,1 );
  136.   blockread( source,lbl,3 );
  137.   filenme := 'XXXXXX';
  138.   for x := 1 to 6 do
  139.     filenme[x] := getdata[x];
  140.   maxnbrrec := ChrToInt(getdata,7,4);
  141.   nbrrecused := ChrToInt(getdata,11,4);
  142.   rcdlen := ChrToInt(getdata,15,3);
  143.   blockingfactor := ChrToInt(getdata,18,2);
  144.   fieldperrecord := ChrToInt(getdata,20,2);
  145.  
  146.   filedate := '        ';
  147.   Move(getdata[22],filedate[1],8);
  148.  
  149. {================================================================}
  150. {  GET LABEL LENGTH, DATA LENGTH & DATA FORM INFO                }
  151. {================================================================}
  152.  
  153. labelposn[1] := 1;
  154. dataposn[1] := 1;
  155.  
  156. for x := 1 to fieldperrecord do
  157.   begin
  158.     labellength[x] :=  BcdToInt(getdata[32+x]);
  159.     datalen[x]     :=  BcdToInt(getdata[64+x]);
  160.     dataform[x]    :=  ord(getdata[96+x])-48;
  161.     labelposn[x+1] :=  labelposn[x] + labellength[x];
  162.     dataposn[x+1]  :=  dataposn[x] + datalen[x];
  163.   end;
  164.  
  165. {================================================================}
  166. {           TRANSLATE REPORT STRUCTURE                           }
  167. {================================================================}
  168.  
  169.   blockread(source,getdata,1);  { SCREEN INFORMATION }
  170.       { ESTABLISH VALUE OF DATAFORM[Z] FOR ASCII INFORMATION }
  171.       if getdata[1] = 'S' then ascii := 9 else ascii := 15;
  172.   for x := 1 to fieldperrecord do
  173.     begin
  174.       w := x*4+1;
  175.       row[x]       := BcdToInt(getdata[w]);
  176.       column[x] := BcdToInt(getdata[w+1])*10+trunc(BcdToInt(getdata[w+2])/10);
  177.       {FIELDNBR[X]  := BCDTOIN(GETDATA[W+3]);} { not implemented }
  178.     end;
  179.  
  180. {================================================================}
  181. {                 BUILD PICTURE IN LINE ARRAY                    }
  182. {================================================================}
  183.  
  184.   for z := 1 to 30 do
  185.     begin
  186.       for x := 0 to 79 do
  187.         line[z][x] := ' ';
  188.       line[z][0] := chr(79);
  189.     end;
  190.   for z := 1 to fieldperrecord do
  191.     begin
  192.       v := column[z];
  193.       for x := labelposn[z] to labelposn[z+1]-1 do
  194.         begin
  195.           line[row[z]][v] := lbl[x];
  196.           v := v+1;
  197.         end;
  198.       line[row[z]][v+1] := ':';
  199.       v := v +3;
  200.  
  201.       mess := '';
  202.       if dataform[z] = ascii then
  203.         begin
  204.           for x := 1 to datalen[z] do
  205.             mess := mess + 'A';
  206.         end
  207.       else
  208.         begin
  209.           mess := '';
  210.           for x := 1 to datalen[z]-1 do
  211.             mess := mess + '_';
  212.           if dataform[z] = 0 then
  213.             mess := mess + '_'
  214.           else
  215.             insert('.',mess,(length(mess)-dataform[z]+1));
  216.           if dataform[z] = 0 then decptr := datalen[z]-2
  217.           else
  218.             decptr := datalen[z] - dataform[z] - 3;
  219.           while decptr >1 do
  220.             begin
  221.               insert(',',mess,decptr);
  222.               decptr := decptr -3;
  223.             end;
  224.         end;
  225.  
  226.       for w := 1 to length(mess) do
  227.         begin
  228.           line[row[z]][v] := mess[w];
  229.           v := v+1;
  230.         end;
  231.       line[row[z]] := copy(line[row[z]],1,79);
  232.       close(source)
  233.     end;
  234.   ClrScr;
  235.   for x := 1 to 22 do
  236.     begin
  237.       line[x] := copy(line[x],1,79);
  238.       writeln(line[x]);
  239.     end;
  240.   x := pos('.',filename);
  241.   if x <> 0 then filename := copy(filename,1,x-1);
  242.   filename := filename + '.PIC';
  243.   Assign (dattopic,filename);
  244.   rewrite(dattopic);
  245.   for x := 1 to 24 do
  246.     begin
  247.       line[x] := copy(line[x],1,79);
  248.       writeln(dattopic,line[x]);
  249.     end;
  250.   close(dattopic);
  251.   GotoXY(1,24);
  252.   writeln(filename,' CREATED');
  253. QUIT:
  254. end.
  255.